{
  Объекты для неизбыточного хранения строковых определений

 TUniqDefList - Каталог уникальных строковых определений
  функции хранения
 - разместить строковое определение
 - изменить строку определения
 - вывести определение
  функции анализа и разложения
 -

 TStrDefItem - Интерфейс к уникальному строковому определению
   def_str: string - строка определения
   use_count: integer - счетчик использования
   simple: boolean - простое или комплексное

 TDefNamItm - Имя предполагаемого элемента
   учз_type: ( s g v o f ) - предполагаемый тип значения

 TExtNamItm - Имя определенного внешнего объекта
   val_type: ( s g v o f ) - тип значения

 TDefBinOper  < @@@ + @@@ - @@@ * @@@ / @@@ ^ @@@ | @@@ & @@@ >
 TDefItmsList < @@@ , @@@ ; @@@ _ @@@ >
 TDefItmMult  < @@@ # @@@ >
 TDefAscCall  < @@@ ? @@@ : @@@ >
 TDefSubCall  < ( @@@ ) >
 TDefFuncCall < @@@ () >
 TDefCallDef  < $ @@@ >
 TDefGrpElmnt < @@@ . @@@ >
 TDefVecItm   < @@@ [ @@@ ] >

   версия 0.0.1 октябрь 2011 prodg@ya.ru D.Kondakov
}
unit StrDefList;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils; 

type
  TStrDefItem = class;
  TUniqDefList = class;

  TStrDefType = (dtText, dtName, dtList, dtExprn);

  PDefItm = ^TDefItm;
  TDefItm = record
    FObject: TStrDefItem;
    FType: TStrDefType;
    FRefCnt: Integer;
  end;

const
  SzDefItm = SizeOf(TDefItm);
  MaxDefLstSize = (Maxint div SzDefItm)-1;

type
  PDefItmLst = ^TDefItmLst;
  TDefItmLst = array[0..MaxDefLstSize] of TDefItm;

  TStrDefLstSortCompare = function(List: TUniqDefList; Index1, Index2: Integer): Integer;

  { TUniqDefList }

  TUniqDefList = class(TStrings)
  private
    FList: PDefItmLst;
    FCount: Integer;
    FCapacity: Integer;
    FUnused: Integer;
    FAutoClean: Boolean;
    procedure Grow;

    //    FOnChange: TNotifyEvent;
    //    FOnChanging: TNotifyEvent;
    //    FDuplicates: TDuplicates; (dupIgnore, dupAccept, dupError)

    //    FSorted: true;
    //    FOwnsObjects : true;
    //    FCaseSensitive : true;
//    procedure ExchangeItems(Index1, Index2: Integer);
//    procedure QuickSort(L, R: Integer; CompareFn: TStringListSortCompare);
//    procedure SetSorted(Value: Boolean);
//    procedure SetCaseSensitive(b : boolean);

  protected
    function Get(Index: Integer): string; override;
    function GetCapacity: Integer; override;
    function GetCount: Integer; override;
    function GetObject(Index: Integer): TObject; override;
    procedure Put(Index: Integer; const S: string); override;
    procedure PutObject(Index: Integer; AObject: TObject); override;
    procedure SetCapacity(NewCapacity: Integer); override;
    procedure SetUpdateState(Updating: Boolean); override;
    Function DoCompareText(const s1,s2 : string) : PtrInt; override;
  public
    destructor Destroy; override;
    function Add(const S: string): Integer; override;
    procedure Clear; override;
    procedure Delete(Index: Integer); override;
    procedure Exchange(Index1, Index2: Integer); override;
    function IndexOf(const S: string): Integer; override;
    procedure Insert(Index: Integer; const S: string); override;

  end;

  { TStrDefItem }

  TStrDefItem = class
    function GetItmObject: TObject; virtual;
    function GetItmData: pointer; virtual;
    function GetDefStr: string; virtual;
  end;

implementation

{ TUniqDefList }

procedure TUniqDefList.Grow;
var
  NewCapacity : Integer;
begin
  NewCapacity := FCapacity;
  If NewCapacity >= 256 then NewCapacity := NewCapacity+(NewCapacity Div 4)
  else if NewCapacity = 0 then NewCapacity := 4
  else NewCapacity := NewCapacity*4;
  SetCapacity(NewCapacity);
end;

function TUniqDefList.Get(Index: Integer): string;
begin
  Result := FList^[Index].FObject.GetDefStr;
end;

function TUniqDefList.GetCapacity: Integer;
begin
  Result := FCapacity;
end;

function TUniqDefList.GetCount: Integer;
begin
  Result := FCount;
end;

function TUniqDefList.GetObject(Index: Integer): TObject;
begin
  Result := FList^[Index].FObject.GetItmObject;
end;

procedure TUniqDefList.Put(Index: Integer; const S: string);
begin
  // Error!
end;

procedure TUniqDefList.PutObject(Index: Integer; AObject: TObject);
begin
  // Error!
end;

procedure TUniqDefList.SetCapacity(NewCapacity: Integer);
var NewList: Pointer;
    OldSize, NewSize: Longint;
begin
  if NewCapacity>0 then begin
    NewSize := NewCapacity*SzDefItm;
    GetMem (NewList, NewSize);
    if NewList = nil then NewSize := 0
    else if Assigned(FList) then begin
      OldSize := FCapacity*SzDefItm;
      System.Move (FList^, NewList^, OldSize);
      FillChar(PDefItmLst(NewList)[FCapacity], NewSize-OldSize, 0)
    end;
  end else begin
    NewList := nil;
    NewSize := 0;
  end;
  FreeMem(FList);
  FList := NewList;
  FCapacity := NewCapacity;
end;

procedure TUniqDefList.SetUpdateState(Updating: Boolean);
begin
  inherited SetUpdateState(Updating);
end;

function TUniqDefList.DoCompareText(const s1, s2: string): PtrInt;
begin
  Result := inherited DoCompareText(s1, s2);
end;

destructor TUniqDefList.Destroy;
begin
  inherited Destroy;
end;

function TUniqDefList.Add(const S: string): Integer;
begin
  Result := inherited Add(S);
end;

procedure TUniqDefList.Clear;
var
  i : Longint;
begin
  if FCount = 0 then Exit;
//  Changing;
//  if FOwnsObjects then
//    begin
  for i := 0 to FCount-1 do
    FreeAndNil(FList^[i].FObject);
{  begin
          FList^[I].FString:='';
        end;  }
//    end
{  else
    begin
      For I:=0 to FCount-1 do
        Flist^[I].FString:='';
    end;}
  FCount:=0;
  SetCapacity(0);
//  Changed;
end;

procedure TUniqDefList.Delete(Index: Integer);
begin
//  If (Index<0) or (Index>=FCount) then
//    Error(SlistINdexError,Index);
//  Changing;
//  FList^[Index].FString:='';
//  if FOwnsObjects then
  FreeAndNil(FList^[Index].FObject);
  Dec(FCount);
  if Index<FCount then
    System.Move(FList^[Index+1],
                FList^[Index],
                (Fcount-Index)*SzDefItm);
//  Changed;
end;

procedure TUniqDefList.Exchange(Index1, Index2: Integer);
begin
//  If (Index1<0) or (Index1>=FCount) then
//    Error(SListIndexError,Index1);
//  If (Index2<0) or (Index2>=FCount) then
//    Error(SListIndexError,Index2);
//  Changing;
// ---  ExchangeItems(Index1,Index2);
//  changed;
end;

function TUniqDefList.IndexOf(const S: string): Integer;
begin
  Result := inherited IndexOf(S);
end;

procedure TUniqDefList.Insert(Index: Integer; const S: string);
begin
{  If Sorted then
    Error (SSortedListError,0)
  else
    If (Index<0) or (Index>FCount) then
      Error (SListIndexError,Index)
    else
      InsertItem (Index,S);}
end;

{ TStrDefItem }

function TStrDefItem.GetItmObject: TObject;
begin
  result := nil;
end;

function TStrDefItem.GetItmData: pointer;
begin
  result := nil;
end;

function TStrDefItem.GetDefStr: string;
begin
  result := '';
end;

end.

